home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / scale.stk < prev    next >
Encoding:
Text File  |  1996-07-29  |  7.6 KB  |  250 lines
  1. ;;;;
  2. ;;;; Scale bindings and procs
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date: 17-May-1993 12:35
  20. ;;;; Last file update: 21-Jul-1996 17:08
  21. ;;;;
  22.  
  23. (let ()
  24.  
  25. (define dragging   #f)
  26. (define init-value #f)
  27. (define delta-x       0)
  28. (define delta-y       0)
  29.  
  30. ;;-------------------------------------------------------------------------
  31. ;; The code below creates the default class bindings for entries.
  32. ;;-------------------------------------------------------------------------
  33.  
  34. ;; Standard Motif bindings:
  35.  
  36. (define-binding "Scale" "<Enter>" (|W| x y)
  37.   (when *tk-strict-Motif* 
  38.      (set! Tk::active-bg (tk-get |W| :activebackground))
  39.      (tk-set! |W| :activebackground (tk-get |W| :background)))
  40.   (Tk:scale-activate |W| x y))
  41.  
  42. (define-binding "Scale" "<Motion>" (|W| x y)
  43.   (Tk:scale-activate |W| x y))
  44.  
  45. (define-binding "Scale" "<Leave>" (|W|)
  46.   (if *tk-strict-Motif*
  47.       (tk-set! |W| :activebackground Tk::active-bg))
  48.   (if (equal? (tk-get |W| :state) "active")
  49.       (tk-set! |W| :state "normal")))
  50.  
  51. (define-binding "Scale" "<1>" (|W| x y)
  52.   (Tk:scale-button-down |W| x y))
  53.  
  54. (define-binding "Scale" "<B1-Motion>" (|W| x y)
  55.   (Tk:scale-drag |W| x y))
  56.  
  57. (define-binding "Scale" "<B1-Leave>" () "")
  58.  
  59. (define-binding "Scale" "<B1-Enter>" () "")
  60.  
  61. (define-binding "Scale" "<ButtonRelease-1>" (|W| x y)
  62.   (Tk:cancel-repeat)
  63.   (Tk:scale-end-drag |W|)
  64.   (Tk:scale-activate |W| x y))
  65.  
  66. (define-binding "Scale" "<2>" (|W| x y)
  67.   (Tk:scale-button-2-down |W| x y))
  68.  
  69. (define-binding "Scale" "<B2-Motion>" (|W| x y)
  70.   (Tk:scale-drag |W| x y))
  71.  
  72. (define-binding "Scale" "<B2-Leave>" () "")
  73.  
  74. (define-binding "Scale" "<B2-Enter>" () "")
  75.  
  76. (define-binding "Scale" "<ButtonRelease-2>" (|W| x y)
  77.   (Tk:cancel-repeat)
  78.   (Tk:scale-end-drag |W|)
  79.   (Tk:scale-activate |W| x y))
  80.  
  81. (define-binding "Scale" "<Control-1>" (|W| x y)
  82.   (Tk:scale-control-press |W| x y))
  83.  
  84. (define-binding "Scale" "<Up>" (|W|)
  85.   (Tk:scale-increment |W| 'up 'little 'no-repeat))
  86.  
  87. (define-binding "Scale" "<Down>" (|W|)
  88.   (Tk:scale-increment |W| 'down 'little 'no-repeat))
  89.  
  90. (define-binding "Scale" "<Left>" (|W|)
  91.   (Tk:scale-increment |W| 'up 'little 'no-repeat))
  92.  
  93. (define-binding "Scale" "<Right>" (|W|)
  94.   (Tk:scale-increment |W| 'down 'little 'no-repeat))
  95.  
  96. (define-binding "Scale" "<Control-Up>" (|W|)
  97.   (Tk:scale-increment |W| 'up 'big 'no-repeat))
  98.  
  99. (define-binding "Scale" "<Control-Down>" (|W|)
  100.   (Tk:scale-increment |W| 'down 'big 'no-repeat))
  101.  
  102. (define-binding "Scale" "<Control-Left>" (|W|)
  103.   (Tk:scale-increment |W| 'up 'big 'no-repeat))
  104.  
  105. (define-binding "Scale" "<Control-Right>" (|W|)
  106.   (Tk:scale-increment |W| 'down 'big 'no-repeat))
  107.  
  108. (define-binding "Scale" "<Home>" (|W|)
  109.   (|W| 'set (tk-get |W| :from)))
  110.  
  111. (define-binding "Scale" "<End>" (|W|)
  112.   (|W| 'set (tk-get |W| :to)))
  113.  
  114.  
  115. ;; Tk:scale-activate --
  116. ;; This procedure is invoked to check a given x-y position in the
  117. ;; scale and activate the slider if the x-y position falls within
  118. ;; the slider.
  119. ;;
  120. ;; w -        The scale widget.
  121. ;; x, y -    Mouse coordinates.
  122.  
  123. (define  (Tk:scale-activate w x y)
  124.   (unless (equal? (tk-get w :state) "disabled")
  125.      (tk-set! w :state (if (equal? (w 'identify x y) "slider") "active" "normal"))))
  126.  
  127. ;; Tk:scale-button-down --
  128. ;; This procedure is invoked when a button is pressed in a scale.  It
  129. ;; takes different actions depending on where the button was pressed.
  130. ;;
  131. ;; w -        The scale widget.
  132. ;; x, y -    Mouse coordinates of button press.
  133.  
  134. (define (Tk:scale-button-down w x y)
  135.   (let ((el (w 'identify x y)))
  136.     (set! dragging #f)
  137.     (cond
  138.        ((string=? el "trough1") (Tk:scale-increment w 'up   'little 'initial))
  139.        ((string=? el "trough2") (Tk:scale-Increment w 'down 'little 'initial))
  140.        ((string=? el "slider")  (set! dragging #t)
  141.                 (set! init-value (w 'get))
  142.                 (let ((coords (w 'coords)))
  143.                   (set! delta-x (- x (car  coords)))
  144.                   (set! delta-y (- y (cadr coords)))
  145.                   (w 'configure :sliderrelief "sunken"))))))
  146.  
  147. ;; Tk:scale-drag --
  148. ;; This procedure is called when the mouse is dragged with
  149. ;; mouse button 1 down.  If the drag started inside the slider
  150. ;; (i.e. the scale is active) then the scale's value is adjusted
  151. ;; to reflect the mouse's position.
  152. ;;
  153. ;; w -        The scale widget.
  154. ;; x, y -    Mouse coordinates.
  155.  
  156. (define (Tk:scale-drag w x y)
  157.   (when dragging
  158.      (w 'set (w 'get (- x delta-x) (- y delta-y)))))
  159.  
  160.  
  161. ;; Tk:scale-end-drag --
  162. ;; This procedure is called to end an interactive drag of the
  163. ;; slider.  It just marks the drag as over.
  164. (define (Tk:scale-end-drag w)
  165.   (set! dragging #f)
  166.   (w 'configure :sliderrelief "raised"))
  167.  
  168.  
  169. ;; Tk:scale-increment --
  170. ;; This procedure is invoked to increment the value of a scale and
  171. ;; to set up auto-repeating of the action if that is desired.  The
  172. ;; way the value is incremented depends on the "dir" and "big"
  173. ;; arguments.
  174. ;;
  175. ;; w -        The scale widget.
  176. ;; dir -    "up" means move value towards -from, "down" means
  177. ;;        move towards -to.
  178. ;; size -    Size of increments: "big" or "little".
  179. ;; repeat -    Whether and how to auto-repeat the action:  "no-repeat"
  180. ;;        means don't auto-repeat, "initial" means this is the
  181. ;;        first action in an auto-repeat sequence, and "again"
  182. ;;        means this is the second repetition or later.
  183.  
  184. (define (Tk:scale-increment w dir size repeat)
  185.   (when (winfo 'exists w)
  186.     (let ((inc  0)
  187.       (from (tk-get w :from))
  188.       (to   (tk-get w :to)))
  189.  
  190.       (if (eqv? size 'big)
  191.       (begin
  192.         (set! inc (tk-get w :bigincrement))
  193.         (if (= inc 0)
  194.         (set! inc (abs (/ (- to from) #i10))))
  195.         (set! inc (max (tk-get w :resolution) inc)))
  196.       (set! inc (tk-get w :resolution)))
  197.     
  198.       (if (or (and (> from to) (eqv? dir 'down)) (and (<= from to) (eqv? dir 'up)))
  199.       (set! inc (- inc)))
  200.  
  201.       (w 'set (+ (w 'get) inc))
  202.  
  203.       (case repeat
  204.     ((again)   (set! tk::after-id 
  205.              (after (tk-get w :repeatinterval)
  206.                 (lambda () 
  207.                   (Tk:scale-increment w dir size 'again)))))
  208.     ((initial) (let ((delay (tk-get w :repeatdelay)))
  209.              (if (> delay 0)
  210.              (set! Tk::after-id 
  211.                    (after delay
  212.                       (lambda () 
  213.                     (Tk:scale-increment w dir 
  214.                                 size 'again)))))))))))
  215.  
  216. ;; Tk:scale-control-press --
  217. ;; This procedure handles button presses that are made with the Control
  218. ;; key down.  Depending on the mouse position, it adjusts the scale
  219. ;; value to one end of the range or the other.
  220. ;;
  221. ;; Arguments:
  222. ;; w -        The scale widget.
  223. ;; x, y -    Mouse coordinates where the button was pressed.
  224.  
  225. (define (Tk:scale-control-press w x y)
  226.   (let ((el (w 'identify x y)))
  227.     (cond
  228.       ((string=? el "trough1")  (w 'set (tk-get w :from)))
  229.       ((string=? el "trough2")  (w 'set (tk-get w :to))))))
  230.  
  231. ;; This procedure is invoked when button 2 is pressed over a scale.
  232. ;; It sets the value to correspond to the mouse position and starts
  233. ;; a slider drag.
  234. ;;
  235. ;; Arguments:
  236. ;; w -        The scrollbar widget.
  237. ;; x, y -    Mouse coordinates within the widget.
  238.  
  239. (define (Tk:scale-button-2-down w x y)
  240.   (unless (equal? (tk-get w :state) "disabled")
  241.     (tk-set! w :state "active")
  242.     (w 'set (w 'get x y))
  243.     (set! dragging #t)
  244.     (set! init-value (w 'get))
  245.     (set! delta-x 0)
  246.     (set! delta-y 0)))
  247.  
  248. ;; enf of let
  249. )
  250.